

{
   include Sora\Drawing.f
   include Sora\Images.f
   include Sora\Sprites.f

   include Maru.f
   include Sprig.f
   include Tools.f
   include Vectors.f
}
poppath
\\



Requires Spriteset

s" graphics\perfect_dos_vga.png" s" graphics\perfect_dos_vga.fnt" font.make dos
s" graphics\04b03.png" s" graphics\04b03.fnt" font.make 04b03
s" graphics\ged-gfx.png" Graphic: ged-gfx

0 Value current
Create filename  256 allot
 ." Ctrl+Shift+S to Save As" filename place
Create pal-filename  256 allot
Create selection  0 h, 0 h, 16 h, 16 h,
Create oldrect  0 h, 0 h, 16 h, 16 h,

0 Value tex
64 Constant #colors
16 Value colors/row
20 Value palzoom
0 Value objx
0 Value objy
12 Value zoom
1 Value lindex
0 Value radius
Variable bgcolor
0 Value sprite
0 value animating?
0 value anim-frame
Task: animator
animator main add-task
0 value clipboard  \ surface
Palette: palette

0 value frame-index  \ "index" into sprite's list of frames

: select ( x y w h -- )
   selection 4h!
   SDL_SetClipRect( current selection ) ;

: (frame)   sprite frame-index  find-frame ;
: !frame-index   0 sprite sprite-length wrap   to frame-index  (frame) frame[] rect@ select  ;
: frame-   frame-index 1 - !frame-index ;
: frame+   frame-index 1 + !frame-index ;


white value lcolor
: editing-color   lindex cells palette + ;
\ : lcolor   lindex cells palette + @ ;
: !lcolor   to lcolor ;
: +red   16 * editing-color red+! editing-color @ !lcolor ;
: +green   16 * editing-color green+! editing-color @ !lcolor ;
: +blue   16 * editing-color blue+! editing-color @ !lcolor ;

: selection@   selection rect@ ;
: clipw   selection @width ;
: cliph   selection @height ;

: image-area>
   0 0 current sdl-dims
   area ;

: palette-area>
   objx  cliph zoom * 16 + \ x y
   colors/row palzoom *  #colors colors/row / palzoom * \ w h
   area ;

: subimage-area>
   objx objy  clipw zoom * cliph zoom *  area ;

: frame-area>
   0 screen-h 32 -  sprite sprite-length 32 * 32 area ;

: load-tex
   current ?dup if
      tex delete-texture  sdl-texture to tex
      $101010 bgcolor !
   then ;

: update-tex
   current selection tex sdl-update-texture ;

: have-color?  ( rgba -- flag )
   palette #colors 0 do @+ third = if 2drop true unloop exit then loop 2drop false ;

: (loadpal)
   2dup file-exists not if cr ." Palette not found." 2drop exit then
   2dup pal-filename place palette load-palette ;

: loadpal
   0 parse (loadpal) ;

: savepal
   palette pal-filename count save-palette ;

: savepalas
   0 parse pal-filename place savepal ;

: filename>palette-filename
   filename count -ext pad place
   s" .pal" pad append
   pad count ;

: find-palette
   filename>palette-filename file-exists not if
      filename>palette-filename pal-filename place
      \ This adds any colors not loaded as a palette from the file - basically, support for 32bit
      palette
      current sdl-dims 0 locals| cnt h w |
      h 0 do
         w 0 do
            current i j SPG_GetPixel dup have-color? if
               drop
            else
               !+
               1 +to cnt
               cnt #colors = if drop unloop unloop exit then
            then
         loop
      loop drop
   else
      cr ." Loading palette..."
      pad count (loadpal)
   then
   ;

: !current
   current ?dup if sdl-destroy then
   to current load-tex ;

: spriteset-file
   filename count -ext pad place s" .spr" pad append pad count ;

: (load)
   \ $deadbeef palette !
   2dup filename place  load-surface
   ( palette  load-surface&palette  ) prepare-surface  !current
   \ palette @ $deadbeef = if find-palette else filename>palette-filename pal-filename place then
   spriteset-file file-exists if spriteset-file load-spriteset then
   0 !frame-index ;

: revert   filename count (load) ;

: load  ( -- <image> )
   0 parse (load) ;

: resize  ( w h -- )
   current -rot sdl-resize !current ;

: save
   filename count -ext filename place s" .png" filename append
   current 8 filename count save-surface
   pal-filename <>"" if savepal then
   spriteset-file save-spriteset ;

: saveas  ( -- <image> )
   0 parse filename place save ;

: +select  ( x y -- )
   selection 2 + h+! selection h+!
   selection h@ current sdl-dims drop clipw - > if
      0 selection h! cliph selection 2 + h+!
   else
      selection h@ 0< if
         current sdl-dims drop clipw - selection h!
         cliph negate selection 2 + h+!
      then
   then
   selection@ 2>r >r dup clipw mod - r> 2r> select ;

: c>f
   s>f 255e f/ ;


: screen

   \ screen-w clipw zoom * - to objx
   current sdl-dims drop 20 + 256 max to objx

   update-tex
   bgcolor @ clear-color
   cls  mv-identity
   tex bind-texture

   animating? not if
      \ full image & selection
      0 0 at
      current sdl-dims red rect
      tex100% current sdl-dims white texrect
      selection@ 2swap at white rect
   else
      \ animating sprite
      0 0 at
      current sdl-dims red rect
      current sdl-dims 0.5 0.5 2scale anim-frame frame[] @origin 2.0 2.0 2scale 2- +at
      1 1 current sdl-dims texture-granularity
      anim-frame frame[] rect@  area  anim-frame frame[] @flip  ?flip  texbounds
      anim-frame frame[] @dims 2.0 2.0 2scale white texrect
   then

   \ subimage/selection/origin
   objx objy at
   \ clipw zoom * cliph zoom * red rect
   zoom 2 > if
      zoom dup  clipw cliph grey grid
   else
      clipw zoom * cliph zoom * grey rect
   then

   selection rect@ texarea 1 1 current sdl-dims texture-granularity
   clipw zoom * cliph zoom * white texrect


   objx clipw zoom * + 16 +
   objy cliph zoom * 2 / + cliph 3 * 2 / - at
   1 1 current sdl-dims texture-granularity
   selection rect@ 2swap 2over texarea 3.0 3.0 2scale white texrect

   \ text
   0 256 at
   dos white text:[
      ." Selection: " selection .rect cr
      ." Paintbrush Radius: " radius . cr
      ." Image: " filename count -path type cr
      ." Palette: " pal-filename count -path type cr
      ." Spriteset: " spriteset-file -path type
   ;]
   \ 0 20 +at
   \ 04b03 text:[ ." This is a test. " 1 . 2 . 3 . ;]
   \ palette
   palette-area> 2drop at
   palette
   #colors colors/row / 0 do
      @pen 2>r
      colors/row 0 do
         @+ palzoom 1 - palzoom 1 - rot rectf
         palzoom 0 +at
      loop
      2r> palzoom + at
   loop drop
   \ RGB
   palette-area> 2drop -16 0 2+ at
   04b03 red text:[ editing-color red@ . ;] 0 16 +at
   04b03 green text:[ editing-color green@ . ;] 0 16 +at
   04b03 $ffff6030 text:[ editing-color blue@ . ;]

   \ sprite
   0 screen-h 48 - at
   04b03 white text:[
      sprite sprite[] h@ 0< if
         ." No sprite"
      else
         ." Sprite: #" sprite . sprite sprite-name@ type
      then
   ;]
   0 8 +at
   1 1 current sdl-dims texture-granularity
   tex bind-texture
   GL_LINEAR texture!filter
   sprite sprite[] h@ 0< not if
      sprite last-frame
      sprite first-frame begin
         dup (frame) = if 32 32 white rect then
         dup >r frame[] rect@ area  r@ frame[] @flip ?flip texbounds  32 32 white texrect
         r>
      2dup <> while
         34 0 +at
         next-frame
      repeat
      2drop
   then
   GL_NEAREST texture!filter

   \ origin
   zoom 2 > if
      objx objy at
      (frame) frame[] @origin zoom * swap zoom * swap +at
      -2 -2 +at
      ged-gfx bind-image
      32 0 5 5 texarea
      5 5 white texrect
   then
   ;

: cursor
   mouse at
   ged-gfx bind-image
   0 0 16 16 texarea
   16 16 lcolor 255 a texrect ;

: user-exit?
   alt? <f4> key? and ;

[+paint]
: wipe
   current onto  selection@ 2swap at 0 rectf ;

: paint
   current onto  radius lcolor 255 a circlef ;

: erase
   current onto  radius 0 circlef ;

: flood
   current onto  floodfill ;
[-paint]

: selection-mouse
   mouse objx objy 2- zoom / swap zoom / swap  selection rect@ 2drop 2+    ;

: zoom- zoom 2 - 1 max to zoom ;

: zoom+ zoom 2 + dup 3 = if 1 - then 32 min to zoom ;

: creep
   +mouse  mouse dup zoom mod - swap dup zoom mod - swap !mouse ;

: animate
   true to animating?
   editor-mode? off
   0 animator act:[
      begin sprite first-frame
         begin dup -1 <> while
            dup to anim-frame
            dup frame[] delay@ 1 min 4 * pauses
            next-frame
         repeat
         drop
      again
   ;] ;

: -animate
   false to animating?
   editor-mode? on
   animator halt ;


: sprite-  sprite previous-sprite to sprite animating? if animate then  0 !frame-index ;
: sprite+  sprite next-sprite to sprite animating? if animate then 0 !frame-index ;

: modify-frame
   selection@ (frame) frame[] 4h! ;

: *sprite
   s" test" selection@ create-frame create-sprite to sprite  0 to frame-index  ;

: blank
   clear-spriteset
   0 0 16 16 select
   256 256 sdl-new !current
   s" default.pal" (loadpal)
   0 to frame-index
   0 to sprite
   *sprite ;

: *frame
   selection@ create-frame  (frame)  insert-frame  frame+ ;

: copy
   clipboard ?dup if sdl-destroy then
   selection @dims sdl-new to clipboard
   SDL_SetAlpha( current  0  255 )
   SPG_PushBlend( SPG_COPY_SRC_ALPHA )
   SPG_Blit( current selection clipboard 0 )
   SPG_PopBlend drop ;

: paste
   SDL_SetAlpha( clipboard 0  255 )
   SPG_PushBlend( SPG_COPY_SRC_ALPHA )
   SPG_Blit( clipboard 0 current selection )
   SPG_PopBlend drop ;


: duplicate
   selection oldrect 8 move
   clipw 0 +select
   current 0 255 SDL_SetAlpha
   SPG_COPY_SRC_ALPHA SPG_PushBlend
   current oldrect current selection SPG_Blit
   SPG_PopBlend drop
   *frame  ;


: eyedrop
   current selection-mouse sdl-pixel @ bgra<>rgba !lcolor ;

: refresh
   init-all
   0 SDL_ShowCursor
   editor-mode? on
   200 16 SDL_EnableKeyRepeat
   load-tex ;

: *window
   fullscreen? if
      desktop display
   else
      640 480 display
   then
   s" Ged" caption!
   ;

: init
   *window
   blank
   refresh
   ;

: open-dialog
   ofn-image if (load) then
   fullscreen? display? and if *window refresh then ;

: ?save-dialog
   shift? if
      fullscreen? display? and if close-display then
      sfn-image if filename place save then
      display? not if *window refresh then
   else
      save
   then ;

: shift*    shift? if 8 * then ;
: shift-    shift? if negate then ;

: set-loop-point
   sprite frame-index find-frame sprite last-frame next-frame! ;

: srcrect   pad rect! pad ; cstyle
: destrect   pad 8 + rect! pad 8 + ; cstyle
: sign*   dup >r 0< if negate then r> 0= if drop 0 then ;


: selection+
   selection @left selection @top 2+ ;
: strip
   locals| y x |
   x 0> if  selection @width x -  0   x  selection @height  exit then
   y 0> if  0  selection @height y -  selection @width  y  exit then
   x 0< if  0  0  x abs  selection @height exit then
   y 0< if  0  0  selection @width  y abs  exit then
   0 0 0 0 ;

: wrapspot
   locals| y x |
   x 0> if  0 0  exit then
   y 0> if  0 0  exit then
   x 0< if  selection @width x +  0  exit then
   y 0< if  0  selection @height y +  exit then
   9999 9999 ;

: nudge   ( x y -- )
   selection @width selection @height sdl-new  locals| temp  y x |
   SDL_SetAlpha( current  0  255 )
   SPG_PushBlend( SPG_COPY_SRC_ALPHA )
   current  selection  temp  destrect( x  y  0 0  ) SPG_Blit
   current  srcrect( x y strip  2swap selection+ 2swap )   temp  destrect(  x y wrapspot  0 0  )  SPG_Blit
   temp  current  0 0 selection+  SPG_DrawBlit
   SPG_PopBlend drop
   temp sdl-destroy  ;

: set-origin
   selection-mouse (frame) frame[] rect@ 2drop 2- (frame) frame[] !origin ;

: fliph
   (frame) frame[] locals| f |
   f @flip 1 xor f !flip
   ; \ f @left f @width over + swap over - f !width f !left ;

: flipv
   (frame) frame[] locals| f |
   f @flip 2 xor f !flip
   ; \ f @top f @height over + swap over - f !height f !top ;


: ctl
   resize:[ window refresh ;]

   [+paint]

   \ keyboard
   keydown:[
      ctrl? if
         case
            <-> of zoom- endof
            <=> of zoom+ endof
            <c> of copy endof
            <v> of paste endof
            <o> of open-dialog endof
            <p> of s" Palette files" s" *.pal" ofn-specific if (loadpal) then endof
            <r> of revert endof
            <s> of ?save-dialog endof
            <n> of ctrl? if blank then endof
            <d> of ctrl? if duplicate then endof
            <w> of wipe endof
         endcase
      else
         case
            <kp4> of -1 shift* selection 4 + h+! selection@ select endof
            <kp6> of 1 shift* selection 4 + h+! selection@ select endof
            <kp8> of -1 shift* selection 6 + h+! selection@ select endof
            <kp2> of 1 shift* selection 6 + h+! selection@ select endof
            <left> of  shift? if -1 0 nudge else zoom negate 0 creep then endof
            <right> of  shift? if 1 0 nudge else zoom 0 creep then endof
            <up> of  shift? if 0 -1 nudge else 0 zoom negate creep then endof
            <down> of  shift? if 0 1 nudge else 0 zoom creep then endof
            <r> of  1 shift- +red endof
            <g> of  1 shift- +green endof
            <b> of  1 shift- +blue endof
            <kp-> of  zoom- endof
            <kp+> of  zoom+  endof
            <pgdn> of sprite-  endof
            <pgup> of sprite+  endof
            <enter> of alt? not if *sprite then endof
            <ins> of *frame endof
            <del> of sprite frame-index delete-frame endof
            <1> of frame- endof
            <2> of frame+ endof
            <m> of modify-frame endof
            <3> of  clipw negate 0 +select  endof
            <4> of  clipw 0 +select  endof
            <[> of -1 +to radius endof
            <]> of 1 +to radius endof
            <e> of eyedrop endof
            <a> of animating? if -animate else animate then endof
            <l> of set-loop-point endof
            <o> of set-origin endof
            <h> of fliph endof
            <v> of flipv endof
         endcase
      then
   ;]

   <space> key? if selection-mouse at  shift? if erase else paint then then

   <f5> press? if save cr ." Saved" then

   \ temporary: -----
   <f> press? if
      subimage-area> mouse in? if
         shift? if
            selection-mouse at  0 flood
         else
            selection-mouse at  lcolor 255 a flood
         then
      then
   then

   \ mouse
   lb mbutton? if
      image-area> mouse in? if
         mx @ dup clipw mod -
         my @ dup cliph mod -
            clipw cliph select
      then
      palette-area> mouse in? if
         mouse palette-area> 2drop 2-  \ get local coords
         palzoom / swap palzoom / swap colors/row * + dup to lindex
         editing-color @ to lcolor
       then
      subimage-area> mouse in? if
          selection-mouse at  paint
      then
      frame-area> mouse in? if
         mouse drop 32 / !frame-index
      then
   then
   rb mbutton? if
      selection-mouse at  erase
   then
   [-paint] ;

: ?winfull
   alt? <enter> key? and if fullscreen? not to fullscreen? *window refresh then ;

: frame
   ?winfull  ctl  screen  cursor  end-frame  pause  ;

: go
   >seki  begin frame  user-exit?  <break> key?  or until
   >ide ;

: name   sprite sprite-name! ;